home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / UI / XMLRPC.pm < prev   
Encoding:
Perl POD Document  |  2004-09-21  |  10.2 KB  |  323 lines
  1. # POPFILE LOADABLE MODULE
  2. package UI::XMLRPC;
  3.  
  4. #----------------------------------------------------------------------------
  5. #
  6. # This package contains the XML-RPC interface for POPFile, all the methods
  7. # in Classifier::Bayes can be accessed through the XMLRPC interface and
  8. # a typical method would be accessed as follows
  9. #
  10. #     Classifier/Bayes.get_buckets
  11. #
  12. # Copyright (c) 2001-2004 John Graham-Cumming
  13. #
  14. #   This file is part of POPFile
  15. #
  16. #   POPFile is free software; you can redistribute it and/or modify
  17. #   it under the terms of the GNU General Public License as published by
  18. #   the Free Software Foundation; either version 2 of the License, or
  19. #   (at your option) any later version.
  20. #
  21. #   POPFile is distributed in the hope that it will be useful,
  22. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  23. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24. #   GNU General Public License for more details.
  25. #
  26. #   You should have received a copy of the GNU General Public License
  27. #   along with POPFile; if not, write to the Free Software
  28. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  29. #
  30. #   Modified by     Sam Schinke (sschinke@users.sourceforge.net)
  31. #
  32. #----------------------------------------------------------------------------
  33.  
  34. use POPFile::Module;
  35. @ISA = ("POPFile::Module");
  36.  
  37. use POPFile::API;
  38.  
  39. use strict;
  40. use warnings;
  41. use locale;
  42.  
  43. use IO::Socket;
  44. use IO::Select;
  45.  
  46. my $eol = "\015\012";
  47.  
  48. #----------------------------------------------------------------------------
  49. # new
  50. #
  51. #   Class new() function
  52. #----------------------------------------------------------------------------
  53. sub new
  54. {
  55.     my $type = shift;
  56.     my $self = POPFile::Module->new();
  57.  
  58.     bless $self, $type;;
  59.  
  60.     $self->name( 'xmlrpc' );
  61.  
  62.     return $self;
  63. }
  64.  
  65. # ---------------------------------------------------------------------------------------------
  66. #
  67. # initialize
  68. #
  69. # Called to initialize the interface
  70. #
  71. # ---------------------------------------------------------------------------------------------
  72. sub initialize
  73. {
  74.     my ( $self ) = @_;
  75.  
  76.     # By default we are disabled
  77.  
  78.     $self->config_( 'enabled', 0 );
  79.  
  80.     # XML-RPC is available on port 8081 initially
  81.  
  82.     $self->config_( 'port', 8081 );
  83.  
  84.     # Only accept connections from the local machine
  85.  
  86.     $self->config_( 'local', 1 );
  87.  
  88.     $self->{api__} = new POPFile::API;
  89.  
  90.     return 1;
  91. }
  92.  
  93. # ---------------------------------------------------------------------------------------------
  94. #
  95. # start
  96. #
  97. # Called to start the XMLRPC interface running
  98. #
  99. # ---------------------------------------------------------------------------------------------
  100. sub start
  101. {
  102.     my ( $self ) = @_;
  103.  
  104.     if ( $self->config_( 'enabled' ) == 0 ) {
  105.         return 2;
  106.     }
  107.  
  108.     require XMLRPC::Transport::HTTP;
  109.  
  110.     # Tell the user interface module that we having a configuration
  111.     # item that needs a UI component
  112.  
  113.     $self->register_configuration_item_( 'configuration',
  114.                                          'xmlrpc_port',
  115.                                          'xmlrpc-port.thtml',
  116.                                          $self );
  117.  
  118.     $self->register_configuration_item_( 'security',
  119.                                          'xmlrpc_local',
  120.                                          'xmlrpc-local.thtml',
  121.                                          $self );
  122.  
  123.     # We use a single XMLRPC::Lite object to handle requests for access to the
  124.     # Classifier::Bayes object
  125.  
  126.     $self->{server__} = XMLRPC::Transport::HTTP::Daemon->new(   # PROFILE BLOCK START
  127.                                      Proto     => 'tcp',
  128.                                      $self->config_( 'local' )  == 1 ? (LocalAddr => 'localhost') : (),
  129.                                      LocalPort => $self->config_( 'port' ),
  130.                                      Listen    => SOMAXCONN,
  131.                                      Reuse     => 1 );          # PROFILE BLOCK STOP
  132.  
  133.     if ( !defined( $self->{server__} ) ) {
  134.         my $port = $self->config_( 'port' );
  135.         my $name = $self->name();
  136.  
  137.         print <<EOM;
  138.  
  139. \nCouldn't start the $name HTTP interface because POPFile could not bind to the
  140. HTTP port $port. This could be because there is another service
  141. using that port or because you do not have the right privileges on
  142. your system (On Unix systems this can happen if you are not root
  143. and the port you specified is less than 1024).
  144.  
  145. EOM
  146.                     #' # fix some syntax highlighting editors
  147.         return 0;
  148.     }
  149.  
  150.  
  151.     # All requests will get dispatched to the main Classifier::Bayes object, for example
  152.     # the get_bucket_color interface is accessed with the method name.  The actual
  153.     # dispatch is via the POPFile::API object which we create in initialize above.
  154.     #
  155.     #     POPFile/API.get_bucket_color
  156.  
  157.     $self->{api__}->{c} = $self->{classifier__};
  158.     $self->{server__}->dispatch_to( $self->{api__} );
  159.  
  160.     # DANGER WILL ROBINSON!  In order to make a polling XML-RPC server I am using
  161.     # the XMLRPC::Transport::HTTP::Daemon class which uses blocking I/O.  This would
  162.     # be all very well but it seems to be totally ignorning signals on Windows and so
  163.     # POPFile is unstoppable when the handle() method is called.  Forking with this
  164.     # blocking doesn't help much because then we get an unstoppable child.
  165.     #
  166.     # So the solution relies on knowing the internals of XMLRPC::Transport::HTTP::Daemon
  167.     # which is actually a SOAP::Transport::HTTP::Daemon which has a HTTP::Daemon (stored
  168.     # in a private variable called _daemon.  HTTP::Daemon is an IO::Socket::INET which means
  169.     # we can create a selector on it, so here we access a PRIVATE variable on the XMLRPC
  170.     # object.  This is very bad behaviour, but it works until someone changes XMLRPC.
  171.  
  172.     $self->{selector__} = new IO::Select( $self->{server__}->{_daemon} );
  173.  
  174.     return 1;
  175. }
  176.  
  177. # ---------------------------------------------------------------------------------------------
  178. #
  179. # service
  180. #
  181. # Called to handle interface requests
  182. #
  183. # ---------------------------------------------------------------------------------------------
  184. sub service
  185. {
  186.     my ( $self ) = @_;
  187.  
  188.     # See if there's a connection pending on the XMLRPC socket and handle
  189.     # single request
  190.  
  191.     my ( $ready ) = $self->{selector__}->can_read(0);
  192.  
  193.     if ( defined( $ready ) ) {
  194.         if ( my $client = $self->{server__}->accept() ) {
  195.  
  196.             # Check that this is a connection from the local machine, if it's not then we drop it immediately
  197.             # without any further processing.  We don't want to allow remote users to admin POPFile
  198.  
  199.             my ( $remote_port, $remote_host ) = sockaddr_in( $client->peername() );
  200.  
  201.             if ( ( $self->config_( 'local' ) == 0 ) ||              # PROFILE BLOCK START
  202.                  ( $remote_host eq inet_aton( "127.0.0.1" ) ) ) {   # PROFILE BLOCK STOP
  203.                 my $request = $client->get_request();
  204.  
  205.                 # Note that handle() relies on the $request being perfectly valid, so here we
  206.                 # check that it is, if it is not then we don't want to call handle and we'll
  207.                 # return out own error
  208.  
  209.                 if ( defined( $request ) ) {
  210.                     $self->{server__}->request( $request );
  211.  
  212.                     # Note the direct call to SOAP::Transport::HTTP::Server::handle() here, this is
  213.                     # because we have taken the code from XMLRPC::Transport::HTTP::Server::handle()
  214.                     # and reproduced a modification of it here, accepting a single request and handling
  215.                     # it.  This call to the parent of XMLRPC::Transport::HTTP::Server will actually
  216.                     # deal with the request
  217.  
  218.                     $self->{server__}->SOAP::Transport::HTTP::Server::handle();
  219.                     $client->send_response( $self->{server__}->response );
  220.         }
  221.                 $client->close();
  222.             }
  223.         }
  224.     }
  225.  
  226.     return 1;
  227. }
  228.  
  229. # ---------------------------------------------------------------------------------------------
  230. #
  231. # configure_item
  232. #
  233. #    $name            Name of this item
  234. #    $templ           The loaded template that was passed as a parameter
  235. #                     when registering
  236. #    $language        Current language
  237. #
  238. # ---------------------------------------------------------------------------------------------
  239.  
  240. sub configure_item
  241. {
  242.     my ( $self, $name, $templ, $language ) = @_;
  243.  
  244.     if ( $name eq 'xmlrpc_port' ) {
  245.         $templ->param ( 'XMLRPC_Port' => $self->config_( 'port' ) );
  246.     }
  247.  
  248.     if ( $name eq 'xmlrpc_local' ) {
  249.         
  250.         if ( $self->config_( 'local' ) == 1 ) {
  251.             $templ->param( 'XMLRPC_local_on' => 1 );
  252.         }
  253.         else {
  254.             $templ->param( 'XMLRPC_local_on' => 0 );
  255.         }
  256.     }
  257. }
  258.  
  259. # ---------------------------------------------------------------------------------------------
  260. #
  261. # validate_item
  262. #
  263. #    $name            The name of the item being configured, was passed in by the call
  264. #                     to register_configuration_item
  265. #    $templ           The loaded template
  266. #    $language        The language currently in use
  267. #    $form            Hash containing all form items
  268. #
  269. # ---------------------------------------------------------------------------------------------
  270.  
  271. sub validate_item
  272. {
  273.     my ( $self, $name, $templ, $language, $form ) = @_;
  274.  
  275.     # Just check to see if the XML rpc port was change and check its value
  276.  
  277.     if ( $name eq 'xmlrpc_port' ) {
  278.         if ( defined($$form{xmlrpc_port}) ) {
  279.             if ( ( $$form{xmlrpc_port} >= 1 ) && ( $$form{xmlrpc_port} < 65536 ) ) {
  280.                 $self->config_( 'port', $$form{xmlrpc_port} );
  281.                 $templ->param( 'XMLRPC_port_if_error' => 0 );
  282.                 $templ->param( 'XMLRPC_port_updated' => sprintf( $$language{Configuration_XMLRPCUpdate}, $self->config_( 'port' ) ) );
  283.             } 
  284.             else {
  285.                 $templ->param( 'XMLRPC_port_if_error' => 1 );
  286.             }
  287.         }
  288.     }
  289.  
  290.     if ( $name eq 'xmlrpc_local' ) {
  291.         $self->config_( 'local', $$form{xmlrpc_local}-1 ) if ( defined($$form{xmlrpc_local}) );
  292.     }
  293.  
  294.     return '';
  295. }
  296.  
  297. # GETTERS/SETTERS
  298.  
  299. sub classifier
  300. {
  301.     my ( $self, $value ) = @_;
  302.  
  303.     if ( defined( $value ) ) {
  304.         $self->{classifier__} = $value;
  305.     }
  306.  
  307.     return $self->{classifier__};
  308. }
  309.  
  310. sub history
  311. {
  312.     my ( $self, $value ) = @_;
  313.  
  314.     if ( defined( $value ) ) {
  315.         $self->{history__} = $value;
  316.     }
  317.  
  318.     return $self->{history__};
  319. }
  320.  
  321. 1;
  322.  
  323.